home *** CD-ROM | disk | FTP | other *** search
- {*******************************************************}
- { }
- { Delphi VCL Extensions (RX) }
- { }
- { Copyright (c) 2001,2002 SGB Software }
- { Copyright (c) 1997, 1998 Fedor Koshevnikov, }
- { Igor Pavluk and Serge Korolev }
- { }
- {*******************************************************}
-
-
- Unit RxGraph;
-
- interface
-
- {$I RX.INC}
-
- uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
- SysUtils, Classes, Graphics, VclUtils;
-
- type
- {$IFNDEF RX_D3}
- TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf24bit);
- {$ENDIF}
- TMappingMethod = (mmHistogram, mmQuantize, mmTrunc784, mmTrunc666,
- mmTripel, mmGrayscale);
-
- function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;
- function GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;
- procedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;
- Method: TMappingMethod);
- function BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;
- Method: TMappingMethod): TMemoryStream;
- procedure GrayscaleBitmap(Bitmap: TBitmap);
-
- function BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;
- procedure SaveBitmapToFile(const Filename: string; Bitmap: TBitmap;
- Colors: Integer);
-
- function ScreenPixelFormat: TPixelFormat;
- function ScreenColorCount: Integer;
-
- procedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);
- function ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean): TPoint;
-
- const
- DefaultMappingMethod: TMappingMethod = mmHistogram;
-
- { TRxGradient class }
-
- type
- TRxGradient = class(TPersistent)
- private
- FStartColor: TColor;
- FEndColor: TColor;
- FDirection: TFillDirection;
- FStepCount: Byte;
- FVisible: Boolean;
- FOnChange: TNotifyEvent;
- procedure SetStartColor(Value: TColor);
- procedure SetEndColor(Value: TColor);
- procedure SetDirection(Value: TFillDirection);
- procedure SetStepCount(Value: Byte);
- procedure SetVisible(Value: Boolean);
- protected
- procedure Changed; dynamic;
- public
- constructor Create;
- procedure Assign(Source: TPersistent); override;
- procedure Draw(Canvas: TCanvas; Rect: TRect);
- published
- property Direction: TFillDirection read FDirection write SetDirection
- default fdTopToBottom;
- property EndColor: TColor read FEndColor write SetEndColor default clGray;
- property StartColor: TColor read FStartColor write SetStartColor default clSilver;
- property StepCount: Byte read FStepCount write SetStepCount default 64;
- property Visible: Boolean read FVisible write SetVisible default False;
- property OnChange: TNotifyEvent read FOnChange write FOnChange;
- end;
-
- implementation
-
- {$R-}
-
- uses Consts, MaxMin;
-
- procedure InvalidBitmap; near;
- begin
- raise EInvalidGraphic.Create(ResStr(SInvalidBitmap));
- end;
-
- type
- PRGBPalette = ^TRGBPalette;
- TRGBPalette = array [Byte] of TRGBQuad;
-
- function WidthBytes(I: Longint): Longint;
- begin
- Result := ((I + 31) div 32) * 4;
- end;
-
- function PixelFormatToColors(PixelFormat: TPixelFormat): Integer;
- begin
- case PixelFormat of
- pf1bit: Result := 2;
- pf4bit: Result := 16;
- pf8bit: Result := 256;
- else Result := 0;
- end;
- end;
-
- function ScreenPixelFormat: TPixelFormat;
- var
- DC: HDC;
- begin
- DC := GetDC(0);
- try
- case (GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL)) of
- 1: Result := pf1bit;
- 4: Result := pf4bit;
- 8: Result := pf8bit;
- 24: Result := pf24bit;
- else Result := pfDevice;
- end;
- finally
- ReleaseDC(0, DC);
- end;
- end;
-
- function ScreenColorCount: Integer;
- begin
- Result := PixelFormatToColors(ScreenPixelFormat);
- end;
-
- { Quantizing }
- { Quantizing ptocedures based on free C source code written by
- Joe C. Oliphant, CompuServe 71742, 1451, joe_oliphant@csufresno.edu }
-
- const
- MAX_COLORS = 4096;
-
- type
- PQColor = ^TQColor;
- TQColor = record
- RGB: array[0..2] of Byte;
- NewColorIndex: Byte;
- Count: Longint;
- PNext: PQColor;
- end;
-
- PQColorArray = ^TQColorArray;
- TQColorArray = array[0..MAX_COLORS - 1] of TQColor;
-
- PQColorList = ^TQColorList;
- TQColorList = array[0..MaxListSize - 1] of PQColor;
-
- PNewColor = ^TNewColor;
- TNewColor = record
- RGBMin, RGBWidth: array[0..2] of Byte;
- NumEntries: Longint;
- Count: Longint;
- QuantizedColors: PQColor;
- end;
-
- PNewColorArray = ^TNewColorArray;
- TNewColorArray = array[Byte] of TNewColor;
-
- procedure PInsert(ColorList: PQColorList; Number: Integer;
- SortRGBAxis: Integer);
- var
- Q1, Q2: PQColor;
- I, J: Integer;
- Temp: PQColor;
- begin
- for I := 1 to Number - 1 do begin
- Temp := ColorList^[I];
- J := I - 1;
- while (J >= 0) do begin
- Q1 := Temp;
- Q2 := ColorList^[J];
- if (Q1^.RGB[SortRGBAxis] - Q2^.RGB[SortRGBAxis] > 0) then Break;
- ColorList^[J + 1] := ColorList^[J];
- Dec(J);
- end;
- ColorList^[J + 1] := Temp;
- end;
- end;
-
- procedure PSort(ColorList: PQColorList; Number: Integer;
- SortRGBAxis: Integer);
- var
- Q1, Q2: PQColor;
- I, J, N, Nr: Integer;
- Temp, Part: PQColor;
- begin
- if Number < 8 then begin
- PInsert(ColorList, Number, SortRGBAxis);
- Exit;
- end;
- Part := ColorList^[Number div 2];
- I := -1;
- J := Number;
- repeat
- repeat
- Inc(I);
- Q1 := ColorList^[I];
- Q2 := Part;
- N := Q1^.RGB[SortRGBAxis] - Q2^.RGB[SortRGBAxis];
- until (N >= 0);
- repeat
- Dec(J);
- Q1 := ColorList^[J];
- Q2 := Part;
- N := Q1^.RGB[SortRGBAxis] - Q2^.RGB[SortRGBAxis];
- until (N <= 0);
- if (I >= J) then Break;
- Temp := ColorList^[I];
- ColorList^[I] := ColorList^[J];
- ColorList^[J] := Temp;
- until False;
- Nr := Number - I;
- if (I < Number div 2) then begin
- PSort(ColorList, I, SortRGBAxis);
- PSort(PQColorList(@ColorList^[I]), Nr, SortRGBAxis);
- end
- else begin
- PSort(PQColorList(@ColorList^[I]), Nr, SortRGBAxis);
- PSort(ColorList, I, SortRGBAxis);
- end;
- end;
-
- function DivideMap(NewColorSubdiv: PNewColorArray; ColorMapSize: Integer;
- var NewColormapSize: Integer; lpStr: Pointer): Integer;
- var
- I, J: {$IFDEF WIN32} Integer {$ELSE} Cardinal {$ENDIF};
- MaxSize, Index: Integer;
- NumEntries, MinColor,
- MaxColor: {$IFDEF WIN32} Integer {$ELSE} Cardinal {$ENDIF};
- Sum, Count: Longint;
- QuantizedColor: PQColor;
- SortArray: PQColorList;
- SortRGBAxis: Integer;
- begin
- Index := 0; SortRGBAxis := 0;
- while (colormapsize > NewColormapSize) do begin
- MaxSize := -1;
- for I := 0 to NewColormapSize - 1 do begin
- for J := 0 to 2 do begin
- if (NewColorSubdiv^[I].RGBwidth[J] > MaxSize) and
- (NewColorSubdiv^[I].NumEntries > 1) then
- begin
- MaxSize := NewColorSubdiv^[I].RGBwidth[J];
- Index := I;
- SortRGBAxis := J;
- end;
- end;
- end;
- if (MaxSize = -1) then begin
- Result := 1;
- Exit;
- end;
- SortArray := PQColorList(lpStr);
- J := 0;
- QuantizedColor := NewColorSubdiv^[Index].QuantizedColors;
- while (J < NewColorSubdiv^[Index].NumEntries) and
- (QuantizedColor <> nil) do
- begin
- SortArray^[J] := QuantizedColor;
- Inc(J);
- QuantizedColor := QuantizedColor^.pnext;
- end;
- PSort(SortArray, NewColorSubdiv^[Index].NumEntries, SortRGBAxis);
- for J := 0 to NewColorSubdiv^[Index].NumEntries - 2 do
- SortArray^[J]^.pnext := SortArray^[J + 1];
- SortArray^[NewColorSubdiv^[Index].NumEntries - 1]^.pnext := nil;
- NewColorSubdiv^[Index].QuantizedColors := SortArray^[0];
- QuantizedColor := SortArray^[0];
- Sum := NewColorSubdiv^[Index].Count div 2 - QuantizedColor^.Count;
- NumEntries := 1;
- Count := QuantizedColor^.Count;
- Dec(Sum, QuantizedColor^.pnext^.Count);
- while (Sum >= 0) and (QuantizedColor^.pnext <> nil) and
- (QuantizedColor^.pnext^.pnext <> nil) do
- begin
- QuantizedColor := QuantizedColor^.pnext;
- Inc(NumEntries);
- Inc(Count, QuantizedColor^.Count);
- Dec(Sum, QuantizedColor^.pnext^.Count);
- end;
- MaxColor := (QuantizedColor^.RGB[SortRGBAxis]) shl 4;
- MinColor := (QuantizedColor^.pnext^.RGB[SortRGBAxis]) shl 4;
- NewColorSubdiv^[NewColormapSize].QuantizedColors := QuantizedColor^.pnext;
- QuantizedColor^.pnext := nil;
- NewColorSubdiv^[NewColormapSize].Count := Count;
- Dec(NewColorSubdiv^[Index].Count, Count);
- NewColorSubdiv^[NewColormapSize].NumEntries :=
- NewColorSubdiv^[Index].NumEntries - NumEntries;
- NewColorSubdiv^[Index].NumEntries := NumEntries;
- for J := 0 to 2 do begin
- NewColorSubdiv^[NewColormapSize].RGBmin[J] :=
- NewColorSubdiv^[Index].RGBmin[J];
- NewColorSubdiv^[NewColormapSize].RGBwidth[J] :=
- NewColorSubdiv^[Index].RGBwidth[J];
- end;
- NewColorSubdiv^[NewColormapSize].RGBwidth[SortRGBAxis] :=
- NewColorSubdiv^[NewColormapSize].RGBmin[SortRGBAxis] +
- NewColorSubdiv^[NewColormapSize].RGBwidth[SortRGBAxis] -
- MinColor;
- NewColorSubdiv^[NewColormapSize].RGBmin[SortRGBAxis] := MinColor;
- NewColorSubdiv^[Index].RGBwidth[SortRGBAxis] :=
- MaxColor - NewColorSubdiv^[Index].RGBmin[SortRGBAxis];
- Inc(NewColormapSize);
- end;
- Result := 1;
- end;
-
- function Quantize(const bmp: TBitmapInfoHeader; gptr, Data8: Pointer;
- var ColorCount: Integer; var OutputColormap: TRGBPalette): Integer;
- type
- PWord = ^Word;
- var
- P: PByteArray;
- LineBuffer, Data: Pointer;
- LineWidth: Longint;
- TmpLineWidth, NewLineWidth: Longint;
- I, J: Longint;
- Index: Word;
- NewColormapSize, NumOfEntries: Integer;
- Mems: Longint;
- cRed, cGreen, cBlue: Longint;
- lpStr, Temp, Tmp: Pointer;
- NewColorSubdiv: PNewColorArray;
- ColorArrayEntries: PQColorArray;
- QuantizedColor: PQColor;
- begin
- LineWidth := WidthBytes(Longint(bmp.biWidth) * bmp.biBitCount);
- Mems := (Longint(SizeOf(TQColor)) * (MAX_COLORS)) +
- (Longint(SizeOf(TNewColor)) * 256) + LineWidth +
- (Longint(sizeof(PQCOLOR)) * (MAX_COLORS));
- lpStr := AllocMemo(Mems);
- try
- Temp := AllocMemo(Longint(bmp.biWidth) * Longint(bmp.biHeight) *
- SizeOf(Word));
- try
- ColorArrayEntries := PQColorArray(lpStr);
- NewColorSubdiv := PNewColorArray(HugeOffset(lpStr,
- Longint(sizeof(TQColor)) * (MAX_COLORS)));
- LineBuffer := HugeOffset(lpStr, (Longint(sizeof(TQColor)) * (MAX_COLORS)) +
- (Longint(sizeof(TNewColor)) * 256));
- for I := 0 to MAX_COLORS - 1 do begin
- ColorArrayEntries^[I].RGB[0] := I shr 8;
- ColorArrayEntries^[I].RGB[1] := (I shr 4) and $0F;
- ColorArrayEntries^[I].RGB[2] := I and $0F;
- ColorArrayEntries^[I].Count := 0;
- end;
- Tmp := Temp;
- for I := 0 to bmp.biHeight - 1 do begin
- HMemCpy(LineBuffer, HugeOffset(gptr, (bmp.biHeight - 1 - I) *
- LineWidth), LineWidth);
- P := LineBuffer;
- for J := 0 to bmp.biWidth - 1 do begin
- Index := (Longint(P^[2] and $F0) shl 4) +
- Longint(P^[1] and $F0) + (Longint(P^[0] and $F0) shr 4);
- Inc(ColorArrayEntries^[Index].Count);
- P := HugeOffset(P, 3);
- PWord(Tmp)^ := Index;
- Tmp := HugeOffset(Tmp, 2);
- end;
- end;
- for I := 0 to 255 do begin
- NewColorSubdiv^[I].QuantizedColors := nil;
- NewColorSubdiv^[I].Count := 0;
- NewColorSubdiv^[I].NumEntries := 0;
- for J := 0 to 2 do begin
- NewColorSubdiv^[I].RGBmin[J] := 0;
- NewColorSubdiv^[I].RGBwidth[J] := 255;
- end;
- end;
- I := 0;
- while I < MAX_COLORS do begin
- if ColorArrayEntries^[I].Count > 0 then Break;
- Inc(I);
- end;
- QuantizedColor := @ColorArrayEntries^[I];
- NewColorSubdiv^[0].QuantizedColors := @ColorArrayEntries^[I];
- NumOfEntries := 1;
- Inc(I);
- while I < MAX_COLORS do begin
- if ColorArrayEntries^[I].Count > 0 then begin
- QuantizedColor^.pnext := @ColorArrayEntries^[I];
- QuantizedColor := @ColorArrayEntries^[I];
- Inc(NumOfEntries);
- end;
- Inc(I);
- end;
- QuantizedColor^.pnext := nil;
- NewColorSubdiv^[0].NumEntries := NumOfEntries;
- NewColorSubdiv^[0].Count := Longint(bmp.biWidth) * Longint(bmp.biHeight);
- NewColormapSize := 1;
- DivideMap(NewColorSubdiv, ColorCount, NewColormapSize,
- HugeOffset(lpStr, Longint(SizeOf(TQColor)) * (MAX_COLORS) +
- Longint(SizeOf(TNewColor)) * 256 + LineWidth));
- if (NewColormapSize < ColorCount) then begin
- for I := NewColormapSize to ColorCount - 1 do
- FillChar(OutputColormap[I], SizeOf(TRGBQuad), 0);
- end;
- for I := 0 to NewColormapSize - 1 do begin
- J := NewColorSubdiv^[I].NumEntries;
- if J > 0 then begin
- QuantizedColor := NewColorSubdiv^[I].QuantizedColors;
- cRed := 0;
- cGreen := 0;
- cBlue := 0;
- while (QuantizedColor <> nil) do begin
- QuantizedColor^.NewColorIndex := I;
- Inc(cRed, QuantizedColor^.RGB[0]);
- Inc(cGreen, QuantizedColor^.RGB[1]);
- Inc(cBlue, QuantizedColor^.RGB[2]);
- QuantizedColor := QuantizedColor^.pnext;
- end;
- with OutputColormap[I] do begin
- rgbRed := (Longint(cRed shl 4) or $0F) div J;
- rgbGreen := (Longint(cGreen shl 4) or $0F) div J;
- rgbBlue := (Longint(cBlue shl 4) or $0F) div J;
- rgbReserved := 0;
- if (rgbRed <= $10) and (rgbGreen <= $10) and (rgbBlue <= $10) then
- FillChar(OutputColormap[I], SizeOf(TRGBQuad), 0); { clBlack }
- end;
- end;
- end;
- TmpLineWidth := Longint(bmp.biWidth) * SizeOf(Word);
- NewLineWidth := WidthBytes(Longint(bmp.biWidth) * 8);
- ZeroMemory(Data8, NewLineWidth * bmp.biHeight);
- for I := 0 to bmp.biHeight - 1 do begin
- LineBuffer := HugeOffset(Temp, (bmp.biHeight - 1 - I) * TmpLineWidth);
- Data := HugeOffset(Data8, I * NewLineWidth);
- for J := 0 to bmp.biWidth - 1 do begin
- PByte(Data)^ := ColorArrayEntries^[PWord(LineBuffer)^].NewColorIndex;
- LineBuffer := HugeOffset(LineBuffer, 2);
- Data := HugeOffset(Data, 1);
- end;
- end;
- finally
- FreeMemo(Temp);
- end;
- finally
- FreeMemo(lpStr);
- end;
- ColorCount := NewColormapSize;
- Result := 0;
- end;
-
- {
- Procedures to truncate to lower bits-per-pixel, grayscale, tripel and
- histogram conversion based on freeware C source code of GBM package by
- Andy Key (nyangau@interalpha.co.uk). The home page of GBM author is
- at http://www.interalpha.net/customer/nyangau/.
- }
-
- { Truncate to lower bits per pixel }
-
- type
- TTruncLine = procedure(Src, Dest: Pointer; CX: Integer);
-
- { For 6Rx6Gx6B, 7Rx8Gx4B palettes etc. }
-
- const
- Scale04: array[0..3] of Byte = (0, 85, 170, 255);
- Scale06: array[0..5] of Byte = (0, 51, 102, 153, 204, 255);
- Scale07: array[0..6] of Byte = (0, 43, 85, 128, 170, 213, 255);
- Scale08: array[0..7] of Byte = (0, 36, 73, 109, 146, 182, 219, 255);
-
- { For 6Rx6Gx6B, 7Rx8Gx4B palettes etc. }
-
- var
- TruncIndex04: array[Byte] of byte;
- TruncIndex06: array[Byte] of byte;
- TruncIndex07: array[Byte] of byte;
- TruncIndex08: array[Byte] of byte;
-
- { These functions initialises this module }
-
- procedure InitTruncTables;
-
- function NearestIndex(Value: Byte; const Bytes: array of Byte): Byte;
- var
- B, I: Byte;
- Diff, DiffMin: Word;
- begin
- Result := 0;
- B := Bytes[0];
- DiffMin := Abs(Value - B);
- for I := 1 to High(Bytes) do begin
- B := Bytes[I];
- Diff := Abs(Value - B);
- if Diff < DiffMin then begin
- DiffMin := Diff;
- Result := I;
- end;
- end;
- end;
-
- var
- I: Integer;
- begin
- { For 7 Red X 8 Green X 4 Blue palettes etc. }
- for I := 0 to 255 do begin
- TruncIndex04[I] := NearestIndex(Byte(I), Scale04);
- TruncIndex06[I] := NearestIndex(Byte(I), Scale06);
- TruncIndex07[I] := NearestIndex(Byte(I), Scale07);
- TruncIndex08[I] := NearestIndex(Byte(I), Scale08);
- end;
- end;
-
- procedure Trunc(const Header: TBitmapInfoHeader; Src, Dest: Pointer;
- DstBitsPerPixel: Integer; TruncLineProc: TTruncLine);
- var
- SrcScanline, DstScanline: Longint;
- Y: Integer;
- begin
- SrcScanline := (Header.biWidth * 3 + 3) and not 3;
- DstScanline := ((Header.biWidth * DstBitsPerPixel + 31) div 32) * 4;
- for Y := 0 to Header.biHeight - 1 do
- TruncLineProc(HugeOffset(Src, Y * SrcScanline),
- HugeOffset(Dest, Y * DstScanline), Header.biWidth);
- end;
-
- { return 6Rx6Gx6B palette
- This function makes the palette for the 6 red X 6 green X 6 blue palette.
- 216 palette entrys used. Remaining 40 Left blank.
- }
- procedure TruncPal6R6G6B(var Colors: TRGBPalette);
- var
- I, R, G, B: Byte;
- begin
- FillChar(Colors, SizeOf(TRGBPalette), $80);
- I := 0;
- for R := 0 to 5 do
- for G := 0 to 5 do
- for B := 0 to 5 do begin
- Colors[I].rgbRed := Scale06[R];
- Colors[I].rgbGreen := Scale06[G];
- Colors[I].rgbBlue := Scale06[B];
- Colors[I].rgbReserved := 0;
- Inc(I);
- end;
- end;
-
- { truncate to 6Rx6Gx6B one line }
- procedure TruncLine6R6G6B(Src, Dest: Pointer; CX: Integer); far;
- var
- X: Integer;
- R, G, B: Byte;
- begin
- for X := 0 to CX - 1 do begin
- B := TruncIndex06[Byte(Src^)]; Src := HugeOffset(Src, 1);
- G := TruncIndex06[Byte(Src^)]; Src := HugeOffset(Src, 1);
- R := TruncIndex06[Byte(Src^)]; Src := HugeOffset(Src, 1);
- PByte(Dest)^ := 6 * (6 * R + G) + B;
- Dest := HugeOffset(Dest, 1);
- end;
- end;
-
- { truncate to 6Rx6Gx6B }
- procedure Trunc6R6G6B(const Header: TBitmapInfoHeader;
- const Data24, Data8: Pointer);
- begin
- Trunc(Header, Data24, Data8, 8, TruncLine6R6G6B);
- end;
-
- { return 7Rx8Gx4B palette
- This function makes the palette for the 7 red X 8 green X 4 blue palette.
- 224 palette entrys used. Remaining 32 Left blank.
- Colours calculated to match those used by 8514/A PM driver.
- }
- procedure TruncPal7R8G4B(var Colors: TRGBPalette);
- var
- I, R, G, B: Byte;
- begin
- FillChar(Colors, SizeOf(TRGBPalette), $80);
- I := 0;
- for R := 0 to 6 do
- for G := 0 to 7 do
- for B := 0 to 3 do begin
- Colors[I].rgbRed := Scale07[R];
- Colors[I].rgbGreen := Scale08[G];
- Colors[I].rgbBlue := Scale04[B];
- Colors[I].rgbReserved := 0;
- Inc(I);
- end;
- end;
-
- { truncate to 7Rx8Gx4B one line }
- procedure TruncLine7R8G4B(Src, Dest: Pointer; CX: Integer); far;
- var
- X: Integer;
- R, G, B: Byte;
- begin
- for X := 0 to CX - 1 do begin
- B := TruncIndex04[Byte(Src^)]; Src := HugeOffset(Src, 1);
- G := TruncIndex08[Byte(Src^)]; Src := HugeOffset(Src, 1);
- R := TruncIndex07[Byte(Src^)]; Src := HugeOffset(Src, 1);
- PByte(Dest)^ := 4 * (8 * R + G) + B;
- Dest := HugeOffset(Dest, 1);
- end;
- end;
-
- { truncate to 7Rx8Gx4B }
- procedure Trunc7R8G4B(const Header: TBitmapInfoHeader;
- const Data24, Data8: Pointer);
- begin
- Trunc(Header, Data24, Data8, 8, TruncLine7R8G4B);
- end;
-
- { Grayscale support }
-
- procedure GrayPal(var Colors: TRGBPalette);
- var
- I: Byte;
- begin
- FillChar(Colors, SizeOf(TRGBPalette), 0);
- for I := 0 to 255 do FillChar(Colors[I], 3, I);
- end;
-
- procedure Grayscale(const Header: TBitmapInfoHeader; Data24, Data8: Pointer);
- var
- SrcScanline, DstScanline: Longint;
- Y, X: Integer;
- Src, Dest: PByte;
- R, G, B: Byte;
- begin
- SrcScanline := (Header.biWidth * 3 + 3) and not 3;
- DstScanline := (Header.biWidth + 3) and not 3;
- for Y := 0 to Header.biHeight - 1 do begin
- Src := Data24;
- Dest := Data8;
- for X := 0 to Header.biWidth - 1 do begin
- B := Src^; Src := HugeOffset(Src, 1);
- G := Src^; Src := HugeOffset(Src, 1);
- R := Src^; Src := HugeOffset(Src, 1);
- Dest^ := Byte(Longint(Word(R) * 77 + Word(G) * 150 + Word(B) * 29) shr 8);
- Dest := HugeOffset(Dest, 1);
- end;
- Data24 := HugeOffset(Data24, SrcScanline);
- Data8 := HugeOffset(Data8, DstScanline);
- end;
- end;
-
- { Tripel conversion }
-
- procedure TripelPal(var Colors: TRGBPalette);
- var
- I: Byte;
- begin
- FillChar(Colors, SizeOf(TRGBPalette), 0);
- for I := 0 to $40 do begin
- Colors[I].rgbRed := I shl 2;
- Colors[I + $40].rgbGreen := I shl 2;
- Colors[I + $80].rgbBlue := I shl 2;
- end;
- end;
-
- procedure Tripel(const Header: TBitmapInfoHeader; Data24, Data8: Pointer);
- var
- SrcScanline, DstScanline: Longint;
- Y, X: Integer;
- Src, Dest: PByte;
- R, G, B: Byte;
- begin
- SrcScanline := (Header.biWidth * 3 + 3) and not 3;
- DstScanline := (Header.biWidth + 3) and not 3;
- for Y := 0 to Header.biHeight - 1 do begin
- Src := Data24;
- Dest := Data8;
- for X := 0 to Header.biWidth - 1 do begin
- B := Src^; Src := HugeOffset(Src, 1);
- G := Src^; Src := HugeOffset(Src, 1);
- R := Src^; Src := HugeOffset(Src, 1);
- case ((X + Y) mod 3) of
- 0: Dest^ := Byte(R shr 2);
- 1: Dest^ := Byte($40 + (G shr 2));
- 2: Dest^ := Byte($80 + (B shr 2));
- end;
- Dest := HugeOffset(Dest, 1);
- end;
- Data24 := HugeOffset(Data24, SrcScanline);
- Data8 := HugeOffset(Data8, DstScanline);
- end;
- end;
-
- { Histogram/Frequency-of-use method of color reduction }
-
- const
- MAX_N_COLS = 2049;
- MAX_N_HASH = 5191;
-
- function Hash(R, G, B: Byte): Word;
- begin
- Result := Word(Longint(Longint(R + G) * Longint(G + B) *
- Longint(B + R)) mod MAX_N_HASH);
- end;
-
- type
- PFreqRecord = ^TFreqRecord;
- TFreqRecord = record
- B, G, R: Byte;
- Frequency: Longint;
- Nearest: Byte;
- end;
-
- PHist = ^THist;
- THist = record
- ColCount: Longint;
- Rm, Gm, Bm: Byte;
- Freqs: array[0..MAX_N_COLS - 1] of TFreqRecord;
- HashTable: array[0..MAX_N_HASH - 1] of Word;
- end;
-
- function CreateHistogram(R, G, B: Byte): PHist;
- { create empty histogram }
- begin
- GetMem(Result, SizeOf(THist));
- with Result^ do begin
- Rm := R;
- Gm := G;
- Bm := B;
- ColCount := 0;
- end;
- FillChar(Result^.HashTable, MAX_N_HASH * SizeOf(Word), 255);
- end;
-
- procedure ClearHistogram(var Hist: PHist; R, G, B: Byte);
- begin
- with Hist^ do begin
- Rm := R;
- Gm := G;
- Bm := B;
- ColCount := 0;
- end;
- FillChar(Hist^.HashTable, MAX_N_HASH * SizeOf(Word), 255);
- end;
-
- procedure DeleteHistogram(var Hist: PHist);
- begin
- FreeMem(Hist, SizeOf(THist));
- Hist := nil;
- end;
-
- function AddToHistogram(var Hist: THist; const Header: TBitmapInfoHeader;
- Data24: Pointer): Boolean;
- { add bitmap data to histogram }
- var
- Step24: Integer;
- HashColor, Index: Word;
- Rm, Gm, Bm, R, G, B: Byte;
- X, Y, ColCount: Longint;
- begin
- Step24 := ((Header.biWidth * 3 + 3) and not 3) - Header.biWidth * 3;
- Rm := Hist.Rm;
- Gm := Hist.Gm;
- Bm := Hist.Bm;
- ColCount := Hist.ColCount;
- for Y := 0 to Header.biHeight - 1 do begin
- for X := 0 to Header.biWidth - 1 do begin
- B := Byte(Data24^) and Bm; Data24 := HugeOffset(Data24, 1);
- G := Byte(Data24^) and Gm; Data24 := HugeOffset(Data24, 1);
- R := Byte(Data24^) and Rm; Data24 := HugeOffset(Data24, 1);
- HashColor := Hash(R, G, B);
- repeat
- Index := Hist.HashTable[HashColor];
- if (Index = $FFFF) or ((Hist.Freqs[Index].R = R) and
- (Hist.Freqs[Index].G = G) and (Hist.Freqs[Index].B = B)) then Break;
- Inc(HashColor);
- if (HashColor = MAX_N_HASH) then HashColor := 0;
- until False;
- { Note: loop will always be broken out of }
- { We don't allow HashTable to fill up above half full }
- if (Index = $FFFF) then begin
- { Not found in Hash table }
- if (ColCount = MAX_N_COLS) then begin
- Result := False;
- Exit;
- end;
- Hist.Freqs[ColCount].Frequency := 1;
- Hist.Freqs[ColCount].B := B;
- Hist.Freqs[ColCount].G := G;
- Hist.Freqs[ColCount].R := R;
- Hist.HashTable[HashColor] := ColCount;
- Inc(ColCount);
- end
- else begin
- { Found in Hash table, update index }
- Inc(Hist.Freqs[Index].Frequency);
- end;
- end;
- Data24 := HugeOffset(Data24, Step24);
- end;
- Hist.ColCount := ColCount;
- Result := True;
- end;
-
- procedure PalHistogram(var Hist: THist; var Colors: TRGBPalette;
- ColorsWanted: Integer);
- { work out a palette from Hist }
- var
- I, J: Longint;
- MinDist, Dist: Longint;
- MaxJ, MinJ: Longint;
- DeltaB, DeltaG, DeltaR: Longint;
- MaxFreq: Longint;
- begin
- I := 0; MaxJ := 0; MinJ := 0;
- { Now find the ColorsWanted most frequently used ones }
- while (I < ColorsWanted) and (I < Hist.ColCount) do begin
- MaxFreq := 0;
- for J := 0 to Hist.ColCount - 1 do
- if (Hist.Freqs[J].Frequency > MaxFreq) then begin
- MaxJ := J;
- MaxFreq := Hist.Freqs[J].Frequency;
- end;
- Hist.Freqs[MaxJ].Nearest := Byte(I);
- Hist.Freqs[MaxJ].Frequency := 0; { Prevent later use of Freqs[MaxJ] }
- Colors[I].rgbBlue := Hist.Freqs[MaxJ].B;
- Colors[I].rgbGreen := Hist.Freqs[MaxJ].G;
- Colors[I].rgbRed := Hist.Freqs[MaxJ].R;
- Colors[I].rgbReserved := 0;
- Inc(I);
- end;
- { Unused palette entries will be medium grey }
- while I <= 255 do begin
- Colors[I].rgbRed := $80;
- Colors[I].rgbGreen := $80;
- Colors[I].rgbBlue := $80;
- Colors[I].rgbReserved := 0;
- Inc(I);
- end;
- { For the rest, find the closest one in the first ColorsWanted }
- for I := 0 to Hist.ColCount - 1 do begin
- if Hist.Freqs[I].Frequency <> 0 then begin
- MinDist := 3 * 256 * 256;
- for J := 0 to ColorsWanted - 1 do begin
- DeltaB := Hist.Freqs[I].B - Colors[J].rgbBlue;
- DeltaG := Hist.Freqs[I].G - Colors[J].rgbGreen;
- DeltaR := Hist.Freqs[I].R - Colors[J].rgbRed;
- Dist := Longint(DeltaR * DeltaR) + Longint(DeltaG * DeltaG) +
- Longint(DeltaB * DeltaB);
- if (Dist < MinDist) then begin
- MinDist := Dist;
- MinJ := J;
- end;
- end;
- Hist.Freqs[I].Nearest := Byte(MinJ);
- end;
- end;
- end;
-
- procedure MapHistogram(var Hist: THist; const Header: TBitmapInfoHeader;
- Data24, Data8: Pointer);
- { map bitmap data to Hist palette }
- var
- Step24: Integer;
- Step8: Integer;
- HashColor, Index: Longint;
- Rm, Gm, Bm, R, G, B: Byte;
- X, Y: Longint;
- begin
- Step24 := ((Header.biWidth * 3 + 3) and not 3) - Header.biWidth * 3;
- Step8 := ((Header.biWidth + 3) and not 3) - Header.biWidth;
- Rm := Hist.Rm;
- Gm := Hist.Gm;
- Bm := Hist.Bm;
- for Y := 0 to Header.biHeight - 1 do begin
- for X := 0 to Header.biWidth - 1 do begin
- B := Byte(Data24^) and Bm; Data24 := HugeOffset(Data24, 1);
- G := Byte(Data24^) and Gm; Data24 := HugeOffset(Data24, 1);
- R := Byte(Data24^) and Rm; Data24 := HugeOffset(Data24, 1);
- HashColor := Hash(R, G, B);
- repeat
- Index := Hist.HashTable[HashColor];
- if (Hist.Freqs[Index].R = R) and (Hist.Freqs[Index].G = G) and
- (Hist.Freqs[Index].B = B) then Break;
- Inc(HashColor);
- if (HashColor = MAX_N_HASH) then HashColor := 0;
- until False;
- PByte(Data8)^ := Hist.Freqs[Index].Nearest;
- Data8 := HugeOffset(Data8, 1);
- end;
- Data24 := HugeOffset(Data24, Step24);
- Data8 := HugeOffset(Data8, Step8);
- end;
- end;
-
- procedure Histogram(const Header: TBitmapInfoHeader; var Colors: TRGBPalette;
- Data24, Data8: Pointer; ColorsWanted: Integer; Rm, Gm, Bm: Byte);
- { map single bitmap to frequency optimised palette }
- var
- Hist: PHist;
- begin
- Hist := CreateHistogram(Rm, Gm, Bm);
- try
- repeat
- if AddToHistogram(Hist^, Header, Data24) then Break
- else begin
- if (Gm > Rm) then Gm := Gm shl 1
- else if (Rm > Bm) then Rm := Rm shl 1
- else Bm := Bm shl 1;
- ClearHistogram(Hist, Rm, Gm, Bm);
- end;
- until False;
- { Above loop will always be exited as if masks get rough }
- { enough, ultimately number of unique colours < MAX_N_COLS }
- PalHistogram(Hist^, Colors, ColorsWanted);
- MapHistogram(Hist^, Header, Data24, Data8);
- finally
- DeleteHistogram(Hist);
- end;
- end;
-
- { expand to 24 bits-per-pixel }
-
- (*
- procedure ExpandTo24Bit(const Header: TBitmapInfoHeader; Colors: TRGBPalette;
- Data, NewData: Pointer);
- var
- Scanline, NewScanline: Longint;
- Y, X: Integer;
- Src, Dest: Pointer;
- C: Byte;
- begin
- if Header.biBitCount = 24 then begin
- Exit;
- end;
- Scanline := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;
- NewScanline := ((Header.biWidth * 3 + 3) and not 3);
- for Y := 0 to Header.biHeight - 1 do begin
- Src := HugeOffset(Data, Y * Scanline);
- Dest := HugeOffset(NewData, Y * NewScanline);
- case Header.biBitCount of
- 1:
- begin
- C := 0;
- for X := 0 to Header.biWidth - 1 do begin
- if (X and 7) = 0 then begin
- C := Byte(Src^);
- Src := HugeOffset(Src, 1);
- end
- else C := C shl 1;
- PByte(Dest)^ := Colors[C shr 7].rgbBlue;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C shr 7].rgbGreen;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C shr 7].rgbRed;
- Dest := HugeOffset(Dest, 1);
- end;
- end;
- 4:
- begin
- X := 0;
- while X < Header.biWidth - 1 do begin
- C := Byte(Src^);
- Src := HugeOffset(Src, 1);
- PByte(Dest)^ := Colors[C shr 4].rgbBlue;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C shr 4].rgbGreen;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C shr 4].rgbRed;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C and 15].rgbBlue;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C and 15].rgbGreen;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C and 15].rgbRed;
- Dest := HugeOffset(Dest, 1);
- Inc(X, 2);
- end;
- if X < Header.biWidth then begin
- C := Byte(Src^);
- PByte(Dest)^ := Colors[C shr 4].rgbBlue;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C shr 4].rgbGreen;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C shr 4].rgbRed;
- {Dest := HugeOffset(Dest, 1);}
- end;
- end;
- 8:
- begin
- for X := 0 to Header.biWidth - 1 do begin
- C := Byte(Src^);
- Src := HugeOffset(Src, 1);
- PByte(Dest)^ := Colors[C].rgbBlue;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C].rgbGreen;
- Dest := HugeOffset(Dest, 1);
- PByte(Dest)^ := Colors[C].rgbRed;
- Dest := HugeOffset(Dest, 1);
- end;
- end;
- end;
- end;
- end;
- *)
-
- { DIB utility routines }
-
- function GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;
- var
- PalSize: Integer;
- begin
- Result := pfDevice;
- if Bitmap.Palette <> 0 then begin
- GetObject(Bitmap.Palette, SizeOf(Integer), @PalSize);
- if PalSize > 0 then begin
- if PalSize <= 2 then Result := pf1bit
- else if PalSize <= 16 then Result := pf4bit
- else if PalSize <= 256 then Result := pf8bit;
- end;
- end;
- end;
-
- function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;
- {$IFDEF RX_D3}
- begin
- Result := Bitmap.PixelFormat;
- {$ELSE}
- var
- {$IFDEF WIN32}
- BM: Windows.TBitmap;
- {$ELSE}
- BM: WinTypes.TBitmap;
- {$ENDIF}
- begin
- Result := pfDevice;
- if Bitmap.Handle <> 0 then begin
- GetObject(Bitmap.Handle, SizeOf(BM), @BM);
- case BM.bmBitsPixel * BM.bmPlanes of
- 1: Result := pf1bit;
- 4: Result := pf4bit;
- 8: Result := pf8bit;
- 24: Result := pf24bit;
- end;
- end;
- {$ENDIF}
- end;
-
- function BytesPerScanline(PixelsPerScanline, BitsPerPixel,
- Alignment: Longint): Longint;
- begin
- Dec(Alignment);
- Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and
- not Alignment;
- Result := Result div 8;
- end;
-
- procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
- PixelFormat: TPixelFormat);
- {$IFDEF WIN32}
- var
- DS: TDIBSection;
- Bytes: Integer;
- begin
- DS.dsbmih.biSize := 0;
- Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
- if Bytes = 0 then InvalidBitmap
- else if (Bytes >= (SizeOf(DS.dsbm) + SizeOf(DS.dsbmih))) and
- (DS.dsbmih.biSize >= DWORD(SizeOf(DS.dsbmih))) then
- BI := DS.dsbmih
- else begin
- FillChar(BI, sizeof(BI), 0);
- with BI, DS.dsbm do begin
- biSize := SizeOf(BI);
- biWidth := bmWidth;
- biHeight := bmHeight;
- end;
- end;
- case PixelFormat of
- pf1bit: BI.biBitCount := 1;
- pf4bit: BI.biBitCount := 4;
- pf8bit: BI.biBitCount := 8;
- pf24bit: BI.biBitCount := 24;
- else BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
- end;
- BI.biPlanes := 1;
- if BI.biSizeImage = 0 then
- BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
- end;
- {$ELSE WIN32}
- var
- BM: WinTypes.TBitmap;
- begin
- GetObject(Bitmap, SizeOf(BM), @BM);
- with BI do begin
- biSize := SizeOf(BI);
- biWidth := BM.bmWidth;
- biHeight := BM.bmHeight;
- case PixelFormat of
- pf1bit: biBitCount := 1;
- pf4bit: biBitCount := 4;
- pf8bit: biBitCount := 8;
- pf24bit: biBitCount := 24;
- else biBitCount := BM.bmBitsPixel * BM.bmPlanes;
- end;
- biPlanes := 1;
- biXPelsPerMeter := 0;
- biYPelsPerMeter := 0;
- biClrUsed := 0;
- biClrImportant := 0;
- biCompression := BI_RGB;
- if biBitCount in [9..32] then biBitCount := 24;
- biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight;
- end;
- end;
- {$ENDIF WIN32}
-
- procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
- var ImageSize: Longint; BitCount: TPixelFormat);
- var
- BI: TBitmapInfoHeader;
- begin
- InitializeBitmapInfoHeader(Bitmap, BI, BitCount);
- if BI.biBitCount > 8 then begin
- InfoHeaderSize := SizeOf(TBitmapInfoHeader);
- {$IFDEF WIN32}
- if (BI.biCompression and BI_BITFIELDS) <> 0 then
- Inc(InfoHeaderSize, 12);
- {$ENDIF}
- end
- else InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) *
- (1 shl BI.biBitCount);
- ImageSize := BI.biSizeImage;
- end;
-
- function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
- var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
- var
- OldPal: HPALETTE;
- DC: HDC;
- begin
- InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
- {$IFDEF WIN32}
- with TBitmapInfoHeader(BitmapInfo) do biHeight := Abs(biHeight);
- {$ENDIF}
- OldPal := 0;
- DC := CreateCompatibleDC(0);
- try
- if Palette <> 0 then
- begin
- OldPal := SelectPalette(DC, Palette, False);
- RealizePalette(DC);
- end;
- Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight,
- @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
- finally
- if OldPal <> 0 then SelectPalette(DC, OldPal, False);
- DeleteDC(DC);
- end;
- end;
-
- function DIBFromBit(Src: HBITMAP; Pal: HPALETTE; PixelFormat: TPixelFormat;
- var Length: Longint): Pointer;
- var
- HeaderSize: Integer;
- ImageSize: Longint;
- FileHeader: PBitmapFileHeader;
- BI: PBitmapInfoHeader;
- Bits: Pointer;
- begin
- if Src = 0 then InvalidBitmap;
- InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat);
- Length := SizeOf(TBitmapFileHeader) + HeaderSize + ImageSize;
- Result := AllocMemo(Length);
- try
- FillChar(Result^, Length, 0);
- FileHeader := Result;
- with FileHeader^ do
- begin
- bfType := $4D42;
- bfSize := Length;
- bfOffBits := SizeOf(FileHeader^) + HeaderSize;
- end;
- BI := PBitmapInfoHeader(Longint(FileHeader) + SizeOf(FileHeader^));
- Bits := Pointer(Longint(BI) + HeaderSize);
- InternalGetDIB(Src, Pal, BI^, Bits^, PixelFormat);
- except
- FreeMemo(Result);
- raise;
- end;
- end;
-
- { Change bits per pixel in a General Bitmap }
-
- function BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;
- Method: TMappingMethod): TMemoryStream;
- var
- FileHeader: PBitmapFileHeader;
- BI, NewBI: PBitmapInfoHeader;
- Bits: Pointer;
- NewPalette: PRGBPalette;
- NewHeaderSize: Integer;
- ImageSize, Length, Len: Longint;
- P, InitData: Pointer;
- ColorCount: Integer;
- begin
- if Bitmap.Handle = 0 then InvalidBitmap;
- if (GetBitmapPixelFormat(Bitmap) = PixelFormat) and
- (Method <> mmGrayscale) then
- begin
- Result := TMemoryStream.Create;
- try
- Bitmap.SaveToStream(Result);
- Result.Position := 0;
- except
- Result.Free;
- raise;
- end;
- Exit;
- end;
- if not (PixelFormat in [pf1bit, pf4bit, pf8bit, pf24bit]) then
- NotImplemented
- else if (PixelFormat in [pf1bit, pf4Bit]) then begin
- P := DIBFromBit(Bitmap.Handle, Bitmap.Palette, PixelFormat, Length);
- try
- Result := TMemoryStream.Create;
- try
- Result.Write(P^, Length);
- Result.Position := 0;
- except
- Result.Free;
- raise;
- end;
- finally
- FreeMemo(P);
- end;
- Exit;
- end;
- { pf8bit - expand to 24bit first }
- InitData := DIBFromBit(Bitmap.Handle, Bitmap.Palette, pf24bit, Len);
- try
- BI := PBitmapInfoHeader(Longint(InitData) + SizeOf(TBitmapFileHeader));
- if BI^.biBitCount <> 24 then NotImplemented; {!!!}
- Bits := Pointer(Longint(BI) + SizeOf(TBitmapInfoHeader));
- InternalGetDIBSizes(Bitmap.Handle, NewHeaderSize, ImageSize, PixelFormat);
- Length := SizeOf(TBitmapFileHeader) + NewHeaderSize;
- P := AllocMemo(Length);
- try
- ZeroMemory(P, Length);
- NewBI := PBitmapInfoHeader(Longint(P) + SizeOf(TBitmapFileHeader));
- NewPalette := PRGBPalette(Longint(NewBI) + SizeOf(TBitmapInfoHeader));
- FileHeader := PBitmapFileHeader(P);
- InitializeBitmapInfoHeader(Bitmap.Handle, NewBI^, PixelFormat);
- case Method of
- mmQuantize:
- begin
- ColorCount := 256;
- Quantize(BI^, Bits, Bits, ColorCount, NewPalette^);
- NewBI^.biClrImportant := ColorCount;
- end;
- mmTrunc784:
- begin
- TruncPal7R8G4B(NewPalette^);
- Trunc7R8G4B(BI^, Bits, Bits);
- NewBI^.biClrImportant := 224;
- end;
- mmTrunc666:
- begin
- TruncPal6R6G6B(NewPalette^);
- Trunc6R6G6B(BI^, Bits, Bits);
- NewBI^.biClrImportant := 216;
- end;
- mmTripel:
- begin
- TripelPal(NewPalette^);
- Tripel(BI^, Bits, Bits);
- end;
- mmHistogram:
- begin
- Histogram(BI^, NewPalette^, Bits, Bits,
- PixelFormatToColors(PixelFormat), 255, 255, 255);
- end;
- mmGrayscale:
- begin
- GrayPal(NewPalette^);
- GrayScale(BI^, Bits, Bits);
- end;
- end;
- with FileHeader^ do begin
- bfType := $4D42;
- bfSize := Length;
- bfOffBits := SizeOf(FileHeader^) + NewHeaderSize;
- end;
- Result := TMemoryStream.Create;
- try
- Result.Write(P^, Length);
- Result.Write(Bits^, ImageSize);
- Result.Position := 0;
- except
- Result.Free;
- raise;
- end;
- finally
- FreeMemo(P);
- end;
- finally
- FreeMemo(InitData);
- end;
- end;
-
- function BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;
- var
- PixelFormat: TPixelFormat;
- begin
- if Colors <= 2 then PixelFormat := pf1bit
- else if Colors <= 16 then PixelFormat := pf4bit
- else if Colors <= 256 then PixelFormat := pf8bit
- else PixelFormat := pf24bit;
- Result := BitmapToMemoryStream(Bitmap, PixelFormat, DefaultMappingMethod);
- end;
-
- procedure SaveBitmapToFile(const Filename: string; Bitmap: TBitmap;
- Colors: Integer);
- var
- Memory: TStream;
- begin
- if Bitmap.Monochrome then Colors := 2;
- Memory := BitmapToMemory(Bitmap, Colors);
- try
- TMemoryStream(Memory).SaveToFile(Filename);
- finally
- Memory.Free;
- end;
- end;
-
- procedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;
- Method: TMappingMethod);
- var
- M: TMemoryStream;
- begin
- if (Bitmap.Handle = 0) or (GetBitmapPixelFormat(Bitmap) = PixelFormat) then
- Exit;
- M := BitmapToMemoryStream(Bitmap, PixelFormat, Method);
- try
- Bitmap.LoadFromStream(M);
- finally
- M.Free;
- end;
- end;
-
- procedure GrayscaleBitmap(Bitmap: TBitmap);
- begin
- SetBitmapPixelFormat(Bitmap, pf8bit, mmGrayscale);
- end;
-
- function ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean): TPoint;
- var
- Zoom: Double;
- begin
- Result := Point(0, 0);
- if (MaxW <= 0) or (MaxH <= 0) or (ImageW <= 0) or (ImageH <= 0) then
- Exit;
- with Result do
- if Stretch then begin
- Zoom := MaxFloat([ImageW / MaxW, ImageH / MaxH]);
- if (Zoom > 0) then begin
- X := Round(ImageW * 0.98 / Zoom);
- Y := Round(ImageH * 0.98 / Zoom);
- end
- else begin
- X := ImageW;
- Y := ImageH;
- end;
- end
- else begin
- X := MaxW;
- Y := MaxH;
- end;
- end;
-
- procedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);
- var
- X, Y: Integer;
- SaveIndex: Integer;
- begin
- if (Image.Width = 0) or (Image.Height = 0) then Exit;
- SaveIndex := SaveDC(Canvas.Handle);
- try
- with Rect do
- IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
- for X := 0 to (WidthOf(Rect) div Image.Width) do
- for Y := 0 to (HeightOf(Rect) div Image.Height) do
- Canvas.Draw(Rect.Left + X * Image.Width,
- Rect.Top + Y * Image.Height, Image);
- finally
- RestoreDC(Canvas.Handle, SaveIndex);
- end;
- end;
-
- { TRxGradient }
-
- constructor TRxGradient.Create;
- begin
- inherited Create;
- FStartColor := clSilver;
- FEndColor := clGray;
- FStepCount := 64;
- FDirection := fdTopToBottom;
- end;
-
- procedure TRxGradient.Assign(Source: TPersistent);
- begin
- if Source is TRxGradient then begin
- with TRxGradient(Source) do begin
- Self.FStartColor := StartColor;
- Self.FEndColor := EndColor;
- Self.FStepCount := StepCount;
- Self.FDirection := Direction;
- Self.FVisible := Visible;
- end;
- Changed;
- end
- else inherited Assign(Source);
- end;
-
- procedure TRxGradient.Changed;
- begin
- if Assigned(FOnChange) then FOnChange(Self);
- end;
-
- procedure TRxGradient.Draw(Canvas: TCanvas; Rect: TRect);
- begin
- GradientFillRect(Canvas, Rect, FStartColor, FEndColor, FDirection,
- FStepCount);
- end;
-
- procedure TRxGradient.SetStartColor(Value: TColor);
- begin
- if Value <> FStartColor then begin
- FStartColor := Value;
- Changed;
- end;
- end;
-
- procedure TRxGradient.SetEndColor(Value: TColor);
- begin
- if Value <> FEndColor then begin
- FEndColor := Value;
- Changed;
- end;
- end;
-
- procedure TRxGradient.SetDirection(Value: TFillDirection);
- begin
- if Value <> FDirection then begin
- FDirection := Value;
- Changed;
- end;
- end;
-
- procedure TRxGradient.SetStepCount(Value: Byte);
- begin
- if Value <> FStepCount then begin
- FStepCount := Value;
- Changed;
- end;
- end;
-
- procedure TRxGradient.SetVisible(Value: Boolean);
- begin
- if FVisible <> Value then begin
- FVisible := Value;
- Changed;
- end;
- end;
-
- initialization
- InitTruncTables;
- end.